perm filename FUSUB.F4[FUN,LCS] blob
sn#375363 filedate 1978-08-24 generic text, type T, neo UTF8
SUBROUTINE LO2UP(J)
C CONVERTS ALL LOWER CASE TO UPPER CASE.
J=J.AND..NOT.((J/2).AND."201004020100)
END
SUBROUTINE ACLOUP(I,J)
ACCEPT 1,I,J
CALL LO2UP(I)
CALL LO2UP(J)
1 FORMAT(A1,A3)
END
SUBROUTINE FILNAM(F)
DIMENSION FN(10),FRMT(3),FFF(5)
COMMON FUNC(512),F2(512),K,I
EQUIVALENCE (FUNC,FN),(A,FN(10))
DATA FRMT/'(A',0,')'/,FFF/'1','2','3','4','5'/
1 FORMAT(20A1)
ACCEPT 1,FN
IF(FN(1).EQ.' ')RETURN
DO 2 K=2,9
A=FN(K)
IF(A.EQ.' ')GO TO 3
2 IF(A.EQ.'.')GO TO 3
CALL EXIT
C EXIT IF GARBAGE
3 FRMT(2)=FFF(K-1)
REREAD FRMT,F
CALL LO2UP(F)
END
SUBROUTINE ZFUNC
COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
COMMON FUNC(512),F2(512),K,I
43 TYPE 1
ACCEPT 100,MA,C
CALL LO2UP(MA)
IF(MA.NE.'B')GO TO 76
430 KT=512
C FOR BACKUP
RETURN
76 IF(MA.EQ.'A')GO TO 75
IF(MA.NE.'M')GO TO 73
75 TYPE 39,B
TYPE 2
ACCEPT 3,FNM2
CALL LO2UP(FNM2)
IF(FNM2.EQ.'B')GO TO 43
40 DO 4 K=1,10
5 IF(FNM2.NE.FN(K))GO TO 4
N2=K
GO TO 72
4 CONTINUE
TYPE 74
GO TO 75
74 FORMAT(' FUNCTION NOT FOUND '/)
72 CALL DPYF(N2,F2)
7 TYPE 60
ACCEPT 100,K
CALL LO2UP(K)
IF(K.EQ.'B')GO TO 15
IF(K.EQ.'N')GO TO 15
IF(MA.EQ.'M')GO TO 102
70 TYPE 10
ACCEPT 11,R,R2
REREAD 100,K
CALL LO2UP(K)
IF(K.EQ.'B')GO TO 75
IF(R2.EQ.0)R2=1
IF(R.EQ.0)R=1
DO 13 K=1,512
X=FUNC(K)
FUNC(K)=FUNC(K)*R+F2(K)*R2+C
13 F2(K)=X
GO TO 104
73 IF(MA.NE.'C')GO TO 44
DO 45 K=1,512
F2(K)=FUNC(K)
45 FUNC(K)=FUNC(K)+C
GO TO 104
44 IF(MA.NE.'I')GO TO 46
DO 47 K=1,512
F2(K)=FUNC(K)
47 FUNC(K)=C-FUNC(K)
GO TO 104
46 IF(MA.NE.'R')GO TO 75
48 DO 50 K=1,512
50 F2(K)=FUNC(513-K)
DO 51 K=1,512
X=FUNC(K)
FUNC(K)=F2(K)+C
51 F2(K)=X
GO TO 104
102 DO 103 K=1,512
X=FUNC(K)
FUNC(K)=FUNC(K)*F2(K)+C
103 F2(K)=X
104 A(1,2)=520
CALL NORM(FUNC)
C NORMALIZES THE FUNCTION
CALL DPY(FUNC,1)
TYPE 6
ACCEPT 100,K
CALL LO2UP(K)
IF(K.EQ.'M')GO TO 43
IF(K.NE.'B')RETURN
DO 14 K=1,512
14 FUNC(K)=F2(K)
15 CALL DPY(FUNC,1)
GO TO 43
1 FORMAT
1(' A(DD), M(ULT), R(ETRO), I(NVRT), OR C,N (=ADD CONSTANT N) ',$)
100 FORMAT(A1,F)
2 FORMAT(' 2ND FUNC? ',$)
3 FORMAT(A3)
10 FORMAT(' TYPE RATIO (E.G. 1,2) ',$)
39 FORMAT(10(A1,A3))
11 FORMAT(2F)
6 FORMAT(' F(INISH), OR M(ORE)? ',$)
60 FORMAT(' GO ON? ',$)
END
SUBROUTINE DPYF(N,F)
COMMON/S/H,AMP,CON,PH /GRD/ON
COMMON/RD/ A(50,4),B(2,10),FN(10),XA(10),AA(4,178,10)
1,LX,JX,JT,IDEL,FNUM,FNUM1,Z,FLNM,FLNM1,KT
DIMENSION F(1)
NODPY=-1
IF(N.GT.0)GO TO 8
N=JX
NODPY=0
CC COLGATE 6/74--SEE MAIN AT 1201-18 IF(XA(N).EQ.'SEG')GO TO 5
8 IF(XA(N).NE.'SYNTH')GO TO 5
CALL ZERO(F)
K=1
1 AMP=AA(2,K,N)
H=AA(1,K,N)
PH=AA(3,K,N)
CON=AA(4,K,N)
CALL SYN(F)
K=K+1
IF(AA(1,K,N).NE.999)GO TO 1
CALL NORM(F)
GO TO 4
5 K=1
G=AA(2,1,N)
IF(G.EQ.520)GO TO 6
J=1
IF(G.LE.1)GO TO 22
Y=0
K=0
C FOR START BEYOND STEP 1 - ASSUMES A 0,1.
GO TO 2
22 Y=AA(1,1,N)
2 K=K+1
M=AA(2,K,N)*5.12+.5
IF(M.GT.512)GO TO 6
G=AA(1,K,N)
Z=G-Y
H=M-J+1
IF(H.LT.1)H=1
NN=0
DO 3 L=J,M
F(L)=(NN*Z)/H+Y
3 NN=NN+1
IF(M.EQ.512)GO TO 4
Y=G
J=M+1
GO TO 2
C FOR LONG FUNCS.
6 L=K+1
DO 7 M=1,512
7 F(M)=AA(M,L,N)
4 IF(NODPY)CALL DPY(F,-1)
C NODPY=0 IS FOR PLOTTER AND LPT
C NOW FUNCTION IS FULL AND DISPLAYED
END
SUBROUTINE SYN(F)
COMMON/S/H,AMP,CON,PH
DIMENSION F(1)
DATA FAC/0.703125/,FACP/1.422222/
X=PH*FACP+1.0
C PHASE IS IN DEGREES (0 - 360)
2016 DO 17 L=1,512
XL=SIND(X*FAC)*AMP+CON
IF(CON.LT.100.0)GO TO 1
F(L)=(XL-100.)*F(L)
GO TO 2
1 F(L)=F(L)+XL
C NORMALIZES THE FUNCTION
2 X=X+H
17 IF(X.GT.512.)X=X-512.
END
SUBROUTINE ZERO(F)
DIMENSION F(1)
DO 1 K=1,512
1 F(K)=0
RETURN
END
SUBROUTINE NORM(F)
DIMENSION F(1)
X=F(1)
C NORMALIZES THE FUNCTION
DO 19 K=2,512
XK=ABS(F(K))
19 IF(X.LT.XK)X=XK
DO 20 K=1,512
20 F(K)=F(K)/X
RETURN
END